home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / uflat / uflat.c < prev    next >
C/C++ Source or Header  |  1991-06-18  |  13KB  |  516 lines
  1. /*
  2.    File: uflat.c
  3. */
  4. #include <strings.h>
  5. #include <stdio.h>
  6. #include <tmc.h>
  7. #include <cvr.h>
  8. #include "uflatconst.h"
  9. #include "tmcode.h"
  10. #include "utils.h"
  11.  
  12. /* command line flags */
  13. static int showorig = TRUE;
  14. static int symtabtr = FALSE;
  15. static int anptr = FALSE;
  16. static int stat = FALSE;
  17.  
  18. /* common variables */
  19. #define infile stdin
  20. #define outfile stdout
  21.  
  22. FILE *tracestream = stderr;
  23.  
  24. /* Name of definition to be monitored */
  25. def thedef;
  26. def_list new_defs;        /* remaining atoms, basetypes and thedef */
  27.  
  28. /*
  29.    Table of debugging flags plus associated information.
  30.    Table is ended by an entry with flagchar '\0'
  31. */
  32. static dbflag flagtab[] =
  33.     {{ 'g', &anptr, "trace lambda removal generation" },
  34.      { 's', &stat, "statistics" },
  35.      { 't', &symtabtr, "symbol table tracing" },
  36.      { '\0', (int *)0, "" },
  37.     };
  38.  
  39. /* Given a symbol 's', search the context for a definition with
  40.  * that name, and return a pointer to it.
  41.  */
  42. static ctx_list context;
  43.  
  44. static def find_def (s)
  45.  symbol s;
  46.     { register unsigned int cix;
  47.       register unsigned int dix;
  48.  
  49.       for (cix = 0; cix < context -> sz; cix++)
  50.          { register def_list l = context -> arr[cix] -> defs;
  51.            for (dix = 0; dix < l -> sz; dix++)
  52.           { register def d = l -> arr[dix];
  53.             switch (d -> tag)
  54.                { case TAGDefAtom:
  55.                     if (d -> DefAtom.atnm == s) return (d);
  56.                     break;
  57.  
  58.                  case TAGDefBasetype:
  59.                     if (d -> DefBasetype.basename == s) return (d);
  60.                     break;
  61.  
  62.              case TAGDefVal:
  63.                 if (d -> DefVal.valnm == s) return (d);
  64.                     break;
  65.  
  66.              case TAGDefTyp:
  67.                     if (d -> DefTyp.typnm == s) return (d);
  68.                     break;
  69.  
  70.              case TAGDefCon:
  71.                 break;
  72.  
  73.              default:
  74.                     badtag (d -> tag);
  75.                    };
  76.           };
  77.     }
  78.     return (defNIL);
  79.     };
  80.  
  81. /* Check if symbol 'nm' occurs in formcon 'fc' */
  82. int occurs_in (nm, fc)
  83.  symbol nm;
  84.  formcon fc;
  85.     { switch (fc -> tag)
  86.          { case TAGFCSym:
  87.           if (fc -> FCSym.sym == nm) return (1);
  88.              break;
  89.            case TAGFCList:
  90.           { register int ix;
  91.             register formcon_list fcs = fc -> FCList.l;
  92.             for (ix = 0; ix < fcs -> sz; ix++)
  93.                if (occurs_in (nm, fcs -> arr[ix])) return (1);
  94.           };
  95.           break;
  96.            default:
  97.           badtag (fc -> tag);
  98.           break;
  99.          };
  100.       return (0);
  101.     };
  102.  
  103. /* Given a symbol 'nm', a value 'sv' and a value 'v', return a copy
  104.  * of 'v' with all occurences of 'nm' replaced by a copy of 'sv'.
  105.  */
  106. val_list subs_val_list ();
  107. val subs_val (nm, sv, v)
  108.  symbol nm;
  109.  val sv;
  110.  val v;
  111.     { switch (v -> tag)
  112.          { case TAGVSym:
  113.               if (v -> VSym.sym == nm)
  114.              { return (rdup_val (sv));
  115.              }
  116.           else return (rdup_val (v));
  117.  
  118.            case TAGVLambda:
  119.               if (!(occurs_in (nm, v -> VLambda.lpar)))
  120.              { return (new_VLambda (rdup_formcon (v -> VLambda.lpar),
  121.                     subs_val (nm, sv, v -> VLambda.lval)));
  122.              }
  123.           else return (rdup_val (v));
  124.  
  125.            case TAGVSigma:
  126.            case TAGVSyn:
  127.            case TAGVAppset:
  128.           { fprintf (stderr, "Only directional descriptions allowed\n");
  129.             exit (1);
  130.           };
  131.  
  132.            case TAGVApply:
  133.           return (new_VApply (subs_val (nm, sv, v -> VApply.aval),
  134.                     subs_val (nm, sv, v -> VApply.apar)));
  135.  
  136.            case TAGVWhere:
  137.           { def d;
  138.             def_list dl;
  139.             def_list nl;
  140.             register unsigned int ix;
  141.  
  142.             dl = v -> VWhere.wdefs;
  143.             if ((dl == def_listNIL) || (dl -> sz == 0))
  144.                return (subs_val (nm, sv, v -> VWhere.wval));
  145.  
  146.             nl = new_def_list ();
  147.             room_def_list (nl, dl -> sz);
  148.             nl -> sz = dl -> sz;
  149.             for (ix=0; ix < dl -> sz; ix++)
  150.                { d = dl -> arr[ix];
  151.              if (d -> tag != TAGDefCon) 
  152.                 { nl -> arr[ix] = rdup_def (d);
  153.                 }
  154.              else
  155.                 nl -> arr[ix] = new_DefCon
  156.                 (rdup_orig (d -> DefCon.conorig),
  157.                  subs_val (nm, sv, d -> DefCon.defcon),
  158.                  subs_val (nm, sv, d -> DefCon.conas));
  159.                    };
  160.             return (new_VWhere (nl,
  161.                  subs_val (nm, sv, v -> VWhere.wval)));
  162.           };
  163.  
  164.            case TAGVList:
  165.           return (new_VList (subs_val_list (nm, sv, v -> VList.l)));
  166.  
  167.            case TAGVAtom:
  168.           return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  169.                     rdup_symbol (v -> VAtom.atnm),
  170.                     rdup_parval_list (v -> VAtom.atvpar),
  171.                     subs_val (nm, sv, v -> VAtom.atcpar)));
  172.            default:
  173.           badtag (v -> tag);
  174.          };
  175.     };
  176.  
  177. /* Given a symbol 'nm', a value 'sv' and a value list 'vl', return a copy
  178.  * of 'vl' with all occurences of 'nm' replaced by a copy of 'sv'.
  179.  */
  180. static val_list subs_val_list (nm, sv, vl)
  181.  symbol nm;
  182.  val sv;
  183.  val_list vl;
  184.     { register unsigned int ix;
  185.       val_list nl = new_val_list ();
  186.       if (vl == val_listNIL) return (nl);
  187.       room_val_list (nl, vl -> sz);
  188.       nl -> sz = vl -> sz;
  189.  
  190.       for (ix=0; ix < vl -> sz; ix++)
  191.          nl -> arr[ix] = subs_val (nm, sv, vl -> arr[ix]);
  192.           return (nl);
  193.     };
  194.  
  195. /* Copy all global basetype and atom definitions */
  196. static copy_basenamedefs (new, old)
  197.  def_list new, old;
  198.     { register int ix;
  199.       register def d;
  200.       for (ix = 0; ix < old -> sz; ix++)
  201.          { d = old -> arr[ix];
  202.            switch (d -> tag)
  203.           { case TAGDefAtom:
  204.                app_def_list (new, rdup_def (d));
  205.                break;
  206.             case TAGDefBasetype:
  207.                app_def_list (new, rdup_def (d));
  208.                break;
  209.             case TAGDefVal:
  210.                break;
  211.             case TAGDefCon:
  212.             case TAGDefTyp:
  213.             default:
  214.                badtag (d -> tag);
  215.                break;
  216.           };
  217.          };
  218.     };
  219.  
  220. /*
  221.    Expand thedef 
  222. */
  223. static val expand_val ();
  224. static val_list expand_val_list ();
  225. static def expand_thedef (d)
  226.  def d;
  227.     { val newrhs;
  228.       val rhs = d -> DefVal.valas;
  229.       if (rhs -> tag != TAGVLambda)
  230.          { fprintf (stderr, "Lambda abstractor expected\n");
  231.            exit (1);
  232.          };
  233.       newrhs = new_VLambda (rdup_formcon (rhs -> VLambda.lpar),
  234.                 expand_val (rhs -> VLambda.lval));
  235.       return (new_DefVal (rdup_orig (d -> DefVal.valorig),
  236.                 rdup_symbol (d -> DefVal.valnm),
  237.                 rdup_typ (d -> DefVal.valtyp), newrhs));
  238.     };
  239.  
  240. static val formcon_to_val (fc)
  241.  formcon fc;
  242.     { switch (fc -> tag)
  243.          { case TAGFCSym:
  244.           return (new_VSym (rdup_orig (thedef -> DefVal.valorig),
  245.                     rdup_symbol (fc -> FCSym.sym)));
  246.            case TAGFCList:
  247.           { val_list vl = new_val_list ();
  248.             formcon_list fcl = fc -> FCList.l;
  249.             if ((fcl != formcon_listNIL) && (fcl -> sz != 0))
  250.                { register int ix;
  251.              room_val_list (vl, fcl -> sz);
  252.              vl -> sz = fcl -> sz;
  253.              for (ix=0; ix < fcl -> sz; ix++)
  254.                 vl -> arr[ix] = formcon_to_val (fcl -> arr[ix]);
  255.                };
  256.             return (new_VList (vl));
  257.           };
  258.            default: badtag (fc -> tag);
  259.          };
  260.     };
  261.  
  262. static val try_subst (expr, fc, arg)
  263.  val expr;
  264.  formcon fc;
  265.  val arg;
  266.     { switch (fc -> tag)
  267.          { case TAGFCSym:
  268.           return (subs_val (fc -> FCSym.sym, arg, expr));
  269.            case TAGFCList:
  270.           { formcon_list fcl = fc -> FCList.l;
  271.             def_list dl;
  272.             if ((fcl == formcon_listNIL) || (fcl -> sz == 0))
  273.                return (rdup_val (expr));
  274.             if ((arg -> tag == TAGVList) &&
  275.             (arg -> VList.l -> sz == fcl -> sz))
  276.                { /* formal and actuals match... */
  277.              register int ix;
  278.              val new = rdup_val (expr);
  279.              for (ix = 0; ix < fcl -> sz; ix++)
  280.                 { val prev = new;
  281.                   new = try_subst (prev, fcl -> arr[ix],
  282.                         arg -> VList.l -> arr[ix]);
  283.                   rfre_val (prev);
  284.                 };
  285.              return (new);
  286.                };
  287.             dl = new_def_list ();
  288.             app_def_list (dl, new_DefCon
  289.                     (rdup_orig (thedef -> DefVal.valorig),
  290.                          formcon_to_val (fc),
  291.                      rdup_val (arg)));
  292.             return (new_VWhere (dl, rdup_val (expr)));
  293.           };
  294.            default: badtag (fc -> tag);
  295.          };
  296.     };
  297.  
  298. static val beta_reduce (lab, arg)
  299.  val lab,arg;
  300.     { val expr = rdup_val (lab -> VLambda.lval);
  301.       val mexpr = try_subst (expr, lab -> VLambda.lpar, arg);
  302.       val texpr = expand_val (mexpr);
  303.       rfre_val (expr);
  304.       rfre_val (mexpr);
  305.       return (texpr);
  306.     };
  307.  
  308. static val expand_application (v)
  309.  val v;
  310.     { val appsys = v -> VApply.aval;
  311.       val args = v -> VApply.apar;
  312.       switch (appsys -> tag)
  313.          { case TAGVSym:
  314.           { def found = find_def (appsys -> VSym.sym);
  315.             if (found == defNIL)
  316.                { fprintf (stderr, "Definition not found\n");
  317.              exit (1);
  318.                };
  319.             if ((found -> tag != TAGDefVal) ||
  320.                 (found -> DefVal.valas -> tag != TAGVLambda))
  321.                { fprintf (stderr, "Wrong definition found\n");
  322.              exit (1);
  323.                };
  324.             return (beta_reduce (found -> DefVal.valas, args));
  325.           };
  326.            case TAGVLambda:
  327.           return (beta_reduce (appsys, args));
  328.            case TAGVSigma:
  329.           { fprintf (stderr, "Only directional systems allowed\n");
  330.             exit (1);
  331.           };
  332.            default: badtag (appsys -> tag);
  333.          };
  334.     };
  335.  
  336. static int def_may_be_deleted (d)
  337.  def d;
  338.     { val lhs = d -> DefCon.defcon;
  339.       val rhs = d -> DefCon.conas;
  340.       if (lhs -> tag == TAGVList)
  341.          { val_list vl = lhs -> VList.l;
  342.            if (vl -> sz == 0) return (1);
  343.          };
  344.       if (rhs -> tag == TAGVList)
  345.          { val_list vl = rhs -> VList.l;
  346.            if (vl -> sz == 0) return (1);
  347.          };
  348.       return (0);
  349.     };
  350.  
  351. static val expand_wheres (v)
  352.  val v;
  353.     { def_list wdefs = v -> VWhere.wdefs;
  354.       def_list ndefs;
  355.       val newval;
  356.       register int ix;
  357.       if ((wdefs == def_listNIL) || (wdefs -> sz == 0))
  358.          return (expand_val (v -> VWhere.wval));
  359.       ins_ctx_list (context, 0, new_ctx (rdup_def_list (wdefs)));
  360.       ndefs = new_def_list ();
  361.       for (ix=0; ix < wdefs -> sz; ix++)
  362.          { def d = wdefs -> arr[ix];
  363.            switch (d -> tag)
  364.           { case TAGDefBasetype:
  365.             case TAGDefAtom:
  366.                app_def_list (new_defs, rdup_def (d));
  367.                break;
  368.             case TAGDefVal:
  369.                break;
  370.             case TAGDefCon:
  371.                if (!def_may_be_deleted (d))
  372.                   app_def_list (ndefs, new_DefCon
  373.                 (rdup_orig (d -> DefCon.conorig),
  374.                  rdup_val (d -> DefCon.defcon),
  375.                  expand_val (d -> DefCon.conas)));
  376.                break;
  377.             default:
  378.                badtag (d -> tag);
  379.           };
  380.           };
  381.       if (ndefs -> sz == 0)
  382.          { newval = expand_val (v -> VWhere.wval);
  383.            rfre_def_list (ndefs);
  384.          }
  385.       else
  386.          newval = new_VWhere (ndefs, expand_val (v -> VWhere.wval));
  387.       del_ctx_list (context, 0);
  388.       return (newval);
  389.     };
  390.  
  391. static val expand_val (v)
  392.  val v;
  393.     { switch (v -> tag)
  394.          { case TAGVSym:
  395.           return (rdup_val (v));
  396.            case TAGVLambda:
  397.           { fprintf (stderr, "All abstractors should have vanished\n");
  398.             exit (1);
  399.           };
  400.            case TAGVApply:
  401.           return (expand_application (v));
  402.            case TAGVWhere:
  403.           return (expand_wheres (v));
  404.            case TAGVList:
  405.           return (new_VList (expand_val_list (v -> VList.l)));
  406.            case TAGVAtom:
  407.           return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  408.                 rdup_symbol (v -> VAtom.atnm),
  409.                 rdup_parval_list (v -> VAtom.atvpar),
  410.                 expand_val (v -> VAtom.atcpar)));
  411.            case TAGVAppset:
  412.            case TAGVSigma:
  413.            case TAGVSyn:
  414.           { fprintf (stderr, "Only directional systems allowed\n");
  415.             exit (1);
  416.           };
  417.            default:
  418.           badtag (v -> tag);
  419.          };
  420.     };
  421.  
  422. static val_list expand_val_list (vl)
  423.  val_list vl;
  424.     { register int ix;
  425.       val_list new = new_val_list ();
  426.       for (ix = 0; ix < vl -> sz; ix++)
  427.          app_val_list (new, expand_val (vl -> arr[ix]));
  428.       return (new);
  429.     };
  430.  
  431. /* Print usage of this program */
  432. static void usage (f)
  433.  FILE *f;
  434.      { fprintf (f, "Usage: gen [-d<debugging flags>]\n");
  435.       helpdbflags (f, flagtab);
  436.     };
  437.  
  438. /* scan arguments and options */
  439. static void scanargs (argc, argv)
  440.  int argc;
  441.  char *argv[];
  442.     { int op;
  443.       argv++;
  444.       argc--;
  445.       while (argc>0)
  446.          { if (argv[0][0] != '-')
  447.           { fprintf (stderr, "too many arguments\n");
  448.             usage (stderr);
  449.             exit (1);
  450.           };
  451.            op = argv[0][1];
  452.            switch (op)
  453.          { case 'd': setdbflags (&argv[0][2], flagtab, TRUE);
  454.                  break;
  455.  
  456.            case 'h':
  457.            case 'H': usage (stdout);
  458.                  exit (0);
  459.  
  460.            case 'o': showorig = FALSE;
  461.                  break;
  462.  
  463.            default: usage (stderr);
  464.                 exit (1);
  465.              };
  466.            argc--;
  467.            argv++;
  468.          };
  469.     };
  470.  
  471. static def find_thedef (dl)
  472.  def_list dl;
  473.     { register int ix;
  474.       register def d;
  475.       register def mdef = defNIL;
  476.       for (ix = 0; ix < dl -> sz; ix++)
  477.          { d = dl -> arr[ix];
  478.            if (d -> tag == TAGDefVal) mdef = d;
  479.          };
  480.       if (mdef == defNIL)
  481.          { fprintf ("No expandible definition found\n");
  482.            exit (1);
  483.          };
  484.       return (mdef);
  485.     };
  486.  
  487. main (argc, argv)
  488.  int argc;
  489.  char *argv [];
  490.     { def_list all_defs;
  491.       initsymbol ();
  492.       scanargs (argc, argv);
  493.       tmlineno = 1;
  494.       fprintf (stderr, "uflat: loading...\n");
  495.       if (fscan_def_list (infile, &all_defs))
  496.          { fprintf (stderr, "Read error: (%d): %s\n", tmlineno, tmerrmsg);
  497.                exit (1);
  498.          };
  499.       thedef = find_thedef (all_defs);
  500.       new_defs = new_def_list ();
  501.       context = new_ctx_list ();
  502.       ins_ctx_list (context, 0, new_ctx (rdup_def_list (all_defs)));
  503.       fprintf (stderr, "uflat: expanding...\n");
  504.       copy_basenamedefs (new_defs, all_defs);
  505.       app_def_list (new_defs, expand_thedef (thedef));
  506.       rfre_ctx_list (context);
  507.       fprint_def_list (outfile, new_defs);
  508.       if (stat)
  509.          { rfre_def_list (new_defs);
  510.            rfre_def_list (all_defs);
  511.            flushsymbol ();
  512.            stat_ds (stderr);
  513.            stat_string (stderr);
  514.          };
  515.     }
  516.